perm filename EVAL[LSP,BGB] blob
sn#028616 filedate 1973-03-13 generic text, type T, neo UTF8
00100 SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
00200 EV3: CAR A,(AR1)
00300 FOO MOVEI B,VALUE
00400 PUSHJ P,GET
00500 JUMPN A,EV3A
00600
00700 ;See if the name is in the Symbol Table.
00800 car A,(AR1)
00900 pushj P,GETSYM
01000 jumpe A,UNDFUN ;function object has no definition.
01100 subi A,INUM0
01200 car B,(AR1)
01300 exch A,B ;assume the function is a SAIBR.
01400 FOO movei C,SAIBR
01500 pushj P,PUTPROP
01600 lac A,AR1
01700 jrst EVAL
01800
01900 EV3A: CDR A,(A)
02000 UBDPTR:
02100 FOO CAIN A,UNBOUND
02200 JRST UNDFUN
02300 CDR B,(AR1) ;eval (cons (cdr a)(cdr ar1))
02400 PUSHJ P,CONS
02500 JRST EVAL
00100 ;Delivery us from EVAL...
00200
00300 OEVAL: AOJN T,AEVAL↔POP P,A ;EVAL called as a SUBR.
00350
00400 EVAL: skipn AR1,A↔jrst CPOPJ ;x is NIL.
00500 caile A,INUMIN↔jrst CPOPJ ;x is and INUM.
00600 caml A,orgHWS↔camle A,endFWS
00700 jrst SAIL3 ;x is a SAIL number.
00800 CAR T,(A)↔CAIN T,-1↔JRST EE1 ;x is atomic
00900 CAILE T,INUMIN↔JRST UNDFUN ;(car x) is an INUM.
01000 HLRO TT,(T)↔AOJE TT,EE2 ;(car x) is atomic.
01100 JRST EXP3
01200
00100 ;Atomic X.
00200 EE1:
00300 EV5: CDR AR1,(AR1)
00400 JUMPE AR1,[ dac A,AR1
00500 pushj P,GETSYM
00600 jumpe A,UNBVAR
00700 subi A,inum0
00800 lac B,AR1
00900 exch A,B
01000 FOO movei C,VALUE
01100 pushj P,PUTPROP
01200 lac A,AR1
01300 jrst EVAL]
01400 CAR TT,(AR1)
01500 FOO CAIE TT,FLONUM
01600 FOO CAIN TT,FIXNUM
01700 POPJ P,
01800 EVBIG: CDR AR1,(AR1) ;bignums know about me
01900 FOO CAIE TT,VALUE↔jrst EV5
02000
02100 ;Valuable Property Found.
02200 CAR A,(AR1) ;Pointer to Value Cell.
02210 caml A,orgHWS
02255 camle A,endFWS
02277 jrst SAIL3
02300 CDR AR1,(A) ;Content of Value Cell.
02400 FOO CAIN AR1,UNBOUND
02500 JRST UNBVAR
02600 DAC AR1,A
02700 POPJ P,
00100 ALIST: SKIPE A,-1(P)
00200 PUSHJ P,NUMBERP
00300 DAC SP,SPSV
00400 JUMPN A,AEVAL7 ;number
00500 LAC C,SC2 ;bottom of spec pdl
00600 DAC C,AEVAL5#
00700 SETOM AEVAL2
00800 AEVAL8: LAC C,SP
00900 AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
01000 JRST AEVAL1 ;done
01100 POP C,T ;pointer for next block
01200 AEVAL4: CAMN C,T
01300 JRST AEVAL6 ;thru with block
01400 POP C,AR1
01500 MOVSS AR1
01600 PUSH SP,(AR1) ;save value cell
01700 HLRZM AR1,(AR1) ;store previous value in value cell
01800 DIP AR1,(SP) ;save pointer to spec pdl loc
01900 JRST AEVAL4
02000
02100 FNGUBD: EXCH A,(P) ;spec pdl pointer
02200 PUSHJ P,NUMVAL
02300 LAC D,A
02400 POP SP,TT ;end of block to rebind
02500 FNGUB2: CAMN SP,TT
02600 JRST POPAJ ;done
02700 POP SP,T
02800 MOVSS T ;pointer to value cell
02900 DIP T,(T)
03000 SKIPGE 1(D)
03100 AOBJN D,.-1 ;skip over spec pdl pointers
03200 PUSH D,(T) ;put value cell in spec pdl
03300 HLRZM T,(T) ;restore value cell
03400 JRST FNGUB2
03500
03600 AEVAL: PUSHJ P,ALIST
03700 POP P,A
03800 MOVEI A,UNBIND
03900 EXCH A,(P)
04000 JRST EVAL
00100 AEVAL1: SKIPGE AEVAL2
00200 SKIPN B,-1(P)
00300 JRST ABIND3 ;done with binding
00400
00500 ;alist binding
00600 LAC A,B
00700 PUSHJ P,REVERSE
00800 SKIPA
00900 ABIND2: LAC A,B
01000 CDR B,(A)
01100 CAR A,(A)
01200 CDR AR1,(A)
01300 CAR A,(A)
01400 PUSHJ P,BIND
01500 JUMPN B,ABIND2
01600 ABIND3: PUSH SP,SPSV
01700 POPJ P,
01800
01900 ;spec pdl binding
02000 AEVAL7: LAC A,-1(P)
02100 PUSHJ P,NUMVAL
02200 SETZM AEVAL2
02300 DAC A,AEVAL5 ;point to unbind to
02400 JRST AEVAL8
02500
02600 AEVAL2: 0 ;0 for number, -1 for a-list *
00100
00200 EE2: CDR T,(T)
00300 JUMPE T,EV3
00400 CAR TT,(T)
00500 CDR T,(T)
00600 FOO CAIN TT,SUBR↔ JRST ESB
00800 FOO CAIN TT,SAIBR↔ JRST ESAIB
01000 FOO CAIN TT,LSUBR↔ JRST EELS
01200 FOO CAIN TT,EXPR↔ JRST AEXP
01400 FOO CAIN TT,FSUBR↔ JRST EFS
01600 FOO CAIN TT,MACRO↔ JRST EFM
01800 FOO CAIE TT,FEXPR↔ JRST EE2
02000
02010 ;EVALUATE FEXPR.
02100 CAR T,(T)
02200 HLL T,(AR1)
02300 PUSH P,T
02400 CDR A,(A)
02500 TLO A,400000
02600 PUSH P,A
02700 MOVNI T,1
02800 JRST IAPPLY
02900
02950 ;EVALUATE EXPR.
03000 AEXP: CAR T,(T)
03100 HLL T,(AR1)
03200 EXP3: PUSH P,T
03300 CDR A,(AR1)
03400 CILIST: JSP TT,ILIST
03500 EXP2: JRST IAPPLY
03600
03700 EFS: CAR T,(T)
03800 CDR A,(AR1)
03900 JRST (T)
00010 ;Evaluate SAIL Subroutine.
00100 ESAIB: CDR A,(AR1)
00200 CAR T,(T)
00300 HLL T,(AR1)
00400 PUSH P,T
00500 JSP TT,ILIST
00600
00700 ;PUT DOWN LISP.
00800 DAC 0,LISPAC
00900 LAC 0,[XWD 1,LISPAC+1]
01000 BLT 0,LISPAC+17
01100 ;PICKUP SAIL.
01200 LAC 12,AC12
01300 LAC 16,AC16
01400 LAC 17,AC17
01500 LAC SAI41
01600 DAC JOB41
01700 LAC SAIAPR
01800 DAC JOBAPR
01900
00100 ;Pop LISP stack and Push into SAIL stack.
00200 JRST .+6(T)
00300 POP P,A+4
00400 POP P,A+3
00500 POP P,A+2
00600 POP P,A+1
00700 POP P,A+0
00800 POP P,S
00900 DAC P,LISPAC+14
01000 MOVMS T
01100 JUMPE T,SAIL2
01150 DAC T,TSAVE#
01175 MOVEI T,1
01200
01300 ;Convert LISP numbers into machine numbers.
01400 SAIL1: lac TT,(T)
01500 caile TT,INUMIN
01600 jrst .+4
01700 CDR TT,(TT)
01800 CDR TT,(TT)
01900 skipa TT,(TT)
02000 subi TT,INUM0
02100 dac TT,(T)
02200 push 17,(T)
02300 AOS T↔CAMG T,TSAVE↔JRST SAIL1
02400
02500 SAIL2: PUSHJ 17,(S) ;SAIL SUBROUTINE CALL.
02600 DAC 12,AC12
02700 DAC 16,AC16
02800 DAC 17,AC17
02900
03000 LAC [JSR UUOH]
03100 DAC JOB41
03200 MOVEI APRINT
03300 DAC JOBAPR
03400 LAC 0,LISPAC
03500 LAC 14,LISPAC+14
03600 LAC 15,LISPAC+15
03700 LAC 16,LISPAC+16
03800 LAC 17,LISPAC+17
03900
04000 ;Convert Machine number to a LISP number.
04100 skipa
04200 SAIL3: lac A,(A)
04300 movm C,A
04400 FOO movei B,FIXNUM
04500 tlne C,400
04600 FOO movei B,FLONUM
04700 jrst MAKNUM
00010 ;EVALUATE SUBR.
00100 ESB: CDR A,(AR1)
00200 UUOS2: CAR T,(T)
00300 HLL T,(AR1)
00400 PUSH P,T
00500 JSP TT,ILIST
00600 ESB1: JRST .+NACS+1(T)
00700 POP P,A+4
00800 POP P,A+3
00900 POP P,A+2
01000 POP P,A+1
01100 POPAJ: POP P,A
01200 POPJ P,
01300
01350 ;EVALUATE MACRO.
01400 EFM: CAR T,(T)
01500 CALLF 1,(T)
01600 JRST EVAL
00100
00200 APPLY: MOVEI TT,AP2
00300 CAME T,[-3]
00400 JRST PDLARG
00500 DAC T,APFNG1#
00600 PUSHJ P,ALIST
00700 LAC T,APFNG1
00800 JSP TT,PDLARG
00900 PUSH P,C ;spec pdl pointer
01000 PUSH P,[FNGUBD]
01100 AP2: PUSH P,A
01200 MOVEI T,0
01300 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
01400 CAR C,(B)
01500 PUSH P,C ;push arg
01600 CDR B,(B)
01700 SOJA T,AP3
01800
01900 IAP4: JUMPGE D,TOOFEW ;special case for fexprs
02000 AOJN R,TOOFEW
02100 PUSH P,B
02200 LAC A,SP
02300 PUSHJ P,FIX1A
02400 EXCH A,(P)
02500 LAC B,A
02600 MOVNI R,2
02700 SOJA T,IAP5
02800
02900 FUNCT: PUSH P,A
03000 LAC A,SP
03100 PUSHJ P,FIX1A
03200 POP P,B
03300 CAR B,(B)
03400 PUSHJ P,XCONS
03500 FOO MOVEI B,FUNARG
03600 JRST XCONS
00100 APFNG: SOS T
00200 DAC T,APFNG1
00300 JSP TT,PDLARG ;get args and funarg list
00400 CDR A,(A)
00500 CDR D,(A) ;a-list pointer
00600 CAR A,(A) ;function
00700 HRLZ R,APFNG1 ;no. of args
00800 PUSH P,D
00900 PUSH P,[FNGUBD]
01000 JSP TT,ARGP1 ;replace args and fn name
01100 PUSH P,D ;a-list pointer
01200 PUSHJ P,ALIST ;set up spec pdl
01300 POP P,D
01400 AOS T,APFNG1
01500
01600 ;falls through
00100 ;falls in
00200
00300 IAPPLY: LAC C,T ;state of world at entrance
00400 ADDI C,(P) ;t has - number of args on pdl
00500 ILP1A: CDR B,(C) ;next pdl slot has function- poss fun name in lh
00600 CAILE B,INUMIN
00700 JRST UNDTAG
00800 CAR A,(B)
00900 CAIN A,-1
01000 JRST IAP1 ;fn is atomic
01010 FOO CAIE A,LAMBD.
01100 FOO CAIN A,LAMBDA↔ JRST IAPLMB
01300 FOO CAIN A,FUNARG↔ JRST APFNG
01500 FOO CAIN A,LABEL↔ JRST APLBL
01700 PUSH P,T
01800 LAC A,B
01900 PUSHJ P,EVAL
02000 POP P,T
02100 LAC C,T
02200 ADDI C,(P)
02300 ILP1B: DAC A,(C)
02400 JRST ILP1A
02500
02600 IAPXPR: CAR A,(B)
02700 JRST ILP1B
02800 IAP1: CDR B,(B)
02900 JUMPE B,IAP2
03000 CAR TT,(B)
03100 CDR B,(B)
03200 FOO CAIN TT,EXPR↔ JRST IAPXPR
03400 FOO CAIN TT,LSUBR↔ JRST IAP6
03600 FOO CAIE TT,SUBR↔ JRST IAP1
03800 CAR B,(B)
03900 DAC B,(C)
04000 JRST ESB1
00100 IAPLMB: CDR B,(B)
00200 CAR TT,(B)
00300 DAC SP,SPSV
00400 CDR B,(B)
00500 CAR D,(TT)
00600 CAIN D,-1
00700 JUMPN TT, IAP3
00800 LAC R,T
00900 IPLMB1: JUMPE T,IPLMB2 ;no more args
01000 JUMPE TT,TOMANY ;too many args supplied
01100 IAP5: CAR A,(TT)
01200 MOVEI AR1,1(T)
01300 ADD AR1,P
01400 HLLZ D,(AR1)
01500 DIP A,(AR1)
01600 CDR TT,(TT)
01700 AOJA T,IPLMB1
00100
00200
00300 IPLMB2: JUMPN TT,IAP4 ;too few args supplied
00400 JUMPE R,IAP69
00500 IPLMB4: POP P,AR1
00600 CAR A,AR1
00700 AOJG R,IPLMB3
00800 PUSHJ P,BIND
00900 JRST IPLMB4
01000 IPLMB3: SKIPE BACTRF
01100 JRST APBK1
01200 APBK2: CAR A,(B)
01300 PUSH SP,SPSV
01400 PUSHJ P,EVAL
01500 JRST UNBIND
01600
01700 IAP69: POP P,(P)
01800 CAR A,(B)
01900 JRST EVAL
02000
02100 APBK1: HRRI AR1,CPOPJ
02200 TLNE AR1,-1
02300 PUSH P,AR1
02400 JRST APBK2
02500 IAP6: MOVEI TT,CPOPJ
02600 DAC TT,(C)
02700 CAR B,(B)
02800 JRST (B)
02900
03000 APLBL: DAC SP,SPSV
03100 CDR B,(B)
03200 CAR A,(B)
03300 CDR B,(B)
03400 CAR AR1,(B)
03500 DAC AR1,(C)
03600 PUSHJ P,BIND
03700 MOVEI A,APLBL1
03800 EXCH A,-1(C)
03900 EXCH A,LBLAD#
04000 HRLI A,LBLAD
04100 PUSH SP,A
04200 PUSH SP,SPSV
04300 JRST IAPPLY
04400 APLBL1: PUSH P,LBLAD
04500 JRST SPECSTR
04600
04700 IAP2: CDR A,(C)
04800 FOO MOVEI B,VALUE
04900 PUSHJ P,GET
05000 JUMPE A,UNDTAG
05100 CDR A,(A)
05200 FOO CAIN A,UNBOUND
05300 JRST UNDTAG
05400 JRST ILP1B
05500
05600 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
05700 LAC A,TT
05800 PUSHJ P,BIND
05900 PUSH P,ARG
06000 SUBI C,INUM0
06100 DAP C,ARG
06200 PUSH SP,SPSV
06300 CAR A,(B)
06400 PUSHJ P,EVAL
06500 CDR T,ARG
06600 POP P,ARG
06700 SUBI T,1-INUM0(P)
06800 HRLI T,-1(T)
06900 ADD P,T
07000 JRST UNBIND
07100
07200 ARG: CDR A,X(A) ;*
07300 POPJ P,
07400
07500 SETARG: DAPZ B,@ARG
07600 JRST PROG2
00100 BIND: PUSH P,B
00200 DAPZ A,BIND3#
00300 BIND2:
00400 FOO MOVEI B,VALUE ;bind atom in a to value in ar1,save
00500 PUSHJ P,GET ;old binding on s pdl
00600 JUMPE A,BIND1 ;add value cell
00700 ;SAIL value cells are outside of LISP space.
00800 caml A,orgHWS
00900 camle A,endFWS
01000 jrst[ exch A,(p)↔pushj p,numval
01100 pop p,B↔movem A,(B)↔popj p,]
01200
01300
01400 PUSH SP,(A) ;olde content of value cell.
01500 DIP A,(SP) ;olde address of value cell.
01600 DAPZ AR1,(A) ;new value.
01700 POPBJ: POP P,B
01800 POPJ P,
01900
02000 BIND1:
02100 FOO MOVEI B,UNBOUND
02200 MOVEI A,0↔ PUSHJ P,CONS ;the value cell.
02300 CDR B,@BIND3↔ PUSHJ P,CONS ;2nd word of value pair.
02400 FOO MOVEI B,VALUE↔ PUSHJ P,XCONS ;1st word of value pair.
02500 DAP A,@BIND3
02600 LAC A,BIND3
02700 JRST BIND2
02800
02900 UBD: CAMN SP,B↔POPJ P,
03000 PUSHJ P,UNBIND
03100 JRST UBD
03200
03000 UNBIND:
03100 SPECSTR: LAC TT,(SP)
03200 SUB SP,[XWD 1,1]
03300 JUMPGE TT,.-2 ;syncronize stack
03400 UNBND1: CAMN SP,TT
03500 POPJ P,
03600 POP SP,T
03700 MOVSS T
03800 HLRZM T,(T)
03900 JRST UNBND1
04000
04100 SPECBIND: LAC TT,SP
04200 SPEC1: LDB R,[POINT 13,(T),ACFLD]
04300 CAILE R,17
04400 JRST SPECX
04500 SKIPE R
04600 LAC R,(R)
04700 EXCH R,@(T)
04800 HRL R,(T)
04900 PUSH SP,R
05000 AOJA T,SPEC1
05100 SPECX: PUSH SP,TT
05200 JRST (T)
05300
05400 ;Special case compiler run time routines
05500
05600 %AMAKE: PUSH P,A ;make alist for fsubr that requires it
05700 LAC A,SP
05800 PUSHJ P,FIX1A
05900 LAC B,A
06000 JRST POPAJ
06100
06200 %UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
06300 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
06400 CDR R,(P)
06500 PUSHJ P,ERSUB3
06600 JRST ERREND
06700
06800 %LCALL: MOVN A,T ;set up routine for compile lsubr
06900 ADDI A,INUM0
07000 ADDI T,(P)
07100 PUSH P,T
07200 PUSHJ P,(3)
07300 POP P,T
07400 SUBI T,(P)
07500 HRLI T,-1(T)
07600 ADD P,T
07700 POPJ P,
00100 SUBTTL ARRAY SUBROUTINES --- PAGE 14
00200
00300 ARRERR←-1
00400
00500 ARRAY: PUSHJ P,ARRAYS
00600 HRRI AR2A,1(R)
00700 LAC A,AR2A
00800 PUSH R,[0]
00900 AOBJN A,.-1
01000 ARREND: LAC A,BPPNR#
01100 DAC AR2A,-1(A)
01200 MOVEI A,INUM0+1(R)
01300 FOO DAC A,VBPORG
01400 POPJ P,
01500
01600 ARRAYS: PUSH P,A
01700 FOO LAC A,VBPORG
01800 SUBI A,INUM0
01900 DAC A,BPPNR
02000 FOO LAC A,VBPEND
02100 MOVNI A,-INUM0-2(A)
02200 ADD A,BPPNR ;bporg-bpend+2
02300 DIP A,BPPNR
02400 POP P,A
02500 CDR AR1,(A) ;(cdr l)
02600 CAR A,(A) ;(car l)name
02700 CDR B,BPPNR
02800 ADDI B,2
02900 FOO MOVEI C,SUBR
03000 PUSHJ P,PUTPROP
03100 CAR A,(AR1) ;(cadr l)mode
03200 PUSH P,AR1
03300 PUSHJ P,EVAL ;eval mode
03400 POP P,AR1
03500 DAC A,AMODE#
03600 MOVEI C,44
03700 JUMPE A,ARRY1
03800 MOVEI C,-INUM0(A)
03900 CAILE A,INUMIN
04000 JRST ARRY1
04100 MOVEI C,22
04200 CDR A,BPPNR
04300 LAC B,GCMKL
04400 PUSHJ P,CONS
04500 DAC A,GCMKL
04600 ARRY1: DAC C,BSIZE#
04700 MOVEI A,44
04800 IDIV A,C
04900 DAC A,NBYTES#
05000 CDR A,(AR1) ;(cddr l)bound pair list
05100 JSP TT,ILIST
05200 AOS R,BPPNR
05300 MOVEI AR1,1 ;ar1 is array size
05400 MOVEI AR2A,0 ;ar2a is cumulative residue
05500 AOJGE T,ARRYS ;single dimension
05600 MOVEI D,A-1
05700 SUB D,T ;d is next ac for array code generation
05800 ARRY2: PUSHJ P,ARRB0
05900 TLC TT,(<IMULI>)
06000 DPB D,[POINT 4,TT,ACFLD]
06100 PUSH R,TT
06200 CAIN D,A
06300 JRST ARRY3
06400 MOVSI TT,(<ADD>)
06500 ADDI TT,1(D)
06600 DPB D,[POINT 4,TT,ACFLD]
06700 PUSH R,TT
06800 SOJA D,ARRY2
06900
07000 ARRB0: POP P,TT
07100 EXCH TT,(P)
07200 CAILE TT,INUMIN
07300 JRST ARRB1
07400 CAR A,(TT)
07500 CDR TT,(TT)
07600 SUBI TT,(A)
07700 ADDI TT,1
07800 JRST ARRB2
07900
08000 ARRB1: MOVEI A,INUM0
08100 SUB TT,A
08200 ARRB2: IMUL A,AR1
08300 IMULB AR1,TT
08400 ADDM A,AR2A
08500 POPJ P,
08600
08700 ARRY3: PUSH R,[ADD A,B]
08800 ARRYS: PUSHJ P,ARRB0
08900 CDR TT,BPPNR
09000 DAC AR2A,(TT)
09100 HRLI TT,(<SUB A,>)
09200 PUSH R,TT
09300 PUSH R,[JUMPL A,ARRERR]
09400 LAC TT,AR1
09500 HRLI TT,(<CAIL A,>)
09600 PUSH R,TT
09700 PUSH R,[JRST ARRERR]
09800 IDIV AR1,NBYTES ;calc #words in array
09900 SKIPE AR2A ;correct for remainder non-zero
10000 ADDI AR1,1
10100 LAC TT,NBYTES
10200 SOJE TT,ARRY6
10300 ADDI TT,1
10400 HRLI TT,(<IDIVI A,>)
10500 PUSH R,TT
10600 MOVN TT,BSIZE
10700 LSH TT,14
10800 HRLI TT,(<IMULI B,>)
10900 PUSH R,TT
11000 MOVEI TT,44+200
11100 SUB TT,BSIZE
11200 LSH TT,6
11300 ARRY6: ADD TT,BSIZE
11400 LSH TT,6
11500 SKIPE AR2A,AMODE
11600 CAIL AR2A,INUMIN
11700 ADDI TT,40 ;mode not = t
11800 TLC TT,(<HRLZI C,>)
11900 PUSH R,TT
12000 MOVEI TT,4(R)
12100 HRLI TT,(<ADDI C,(A)>)
12200 PUSH R,TT
12300 PUSH R,[LDB A,C]
12400 HRLZI AR2A,(<POPJ P,>)
12500 SKIPN TT,AMODE
12600 LAC AR2A,[JRST FLO1A]
12700 CAIL TT,INUMIN
12800 LAC AR2A,[JRST FIX1A]
12900 PUSH R,AR2A
13000 MOVS AR2A,AR1
13100 MOVNS AR2A
13200 POPJ P,
13300
00100 EXARRAY: PUSH P,A
00200 CAR A,(A)
00300 PUSHJ P,GETSYM
00400 JUMPE A,POPAJ
00500 PUSHJ P,NUMVAL
00600 EXCH A,(P)
00700 PUSHJ P,ARRAYS
00800 POP P,A
00900 DAP A,-2(R)
01000 HRR AR2A,A
01100 JRST ARREND
01200
01300 STORE: PUSH P,A
01400 PUSHJ P,CADR
01500 PUSHJ P,EVAL ;value to store
01600 EXCH A,(P)
01700 CAR A,(A)
01800 PUSHJ P,EVAL ;byte pointer returned in c
01900 POP P,A
02000 NSTR: PUSH P,A
02100 TLNE C,40
02200 PUSHJ P,NUMVAL ;numerical array
02300 DPB A,C
02400 POP P,A
02500 POPJ P,
00100 SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
00200
00300 BOOLE: LAC TT,T
00400 ADDI TT,2(P)
00500 LAC A,-1(TT)
00600 SUBI A,INUM0
00700 DPB A,[POINT 4,BOOLI,OPFLD-2]
00800 PUSHJ P,BOOLG
00900 LAC C,A
01000 BOOLL: PUSHJ P,BOOLG
01100 BOOLI: SETZB C,A
01200 JRST BOOLL
01300
01400 BOOLG: CAIL TT,(P)
01500 JRST BOOL1
01600 LAC A,(TT)
01700 PUSHJ P,NUMVAL
01800 AOJA TT,CPOPJ
01900
02000 BOOL1: HRLI T,-1(T)
02100 ADD P,T
02200 POP P,B
02300 JRST FIX1A
02400
02500 EXAMINE: LAC A,-INUM0(A)
02600 JRST FIX1A
02700
02800 DEPOSIT: MOVEI C,-INUM0(A)
02900 LAC A,B
03000 PUSHJ P,NUMVAL
03100 DAC A,(C)
03200 JRST MAKNUM
03300
03400 LSH: MOVEI C,-INUM0(B)
03500 PUSHJ P,NUMVAL
03600 LSH A,(C)
03700 JRST FIX1A